perm filename BX.F4[NEW,LCS] blob
sn#356862 filedate 1978-05-24 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C*** BEAMS, BMREAD ************
C00027 ENDMK
C⊗;
C*** BEAMS, BMREAD ************
SUBROUTINE BEAMS
INTEGER UPDN
COMMON R2,JAZ,CENTR,JBZ,RJQ(20),JQ(20) /STF/RSTFAC(8),RSTJ2
1 /XRN/RN(1) /PTR/KWDS(1) /RNW/RNW /A2Z/LAA,LBB
1 /RINP/R(10,85),POSNT(0/99) /RMOD/RMODE2,SET4,IBEAM,
1 NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM,IT,POS
1 /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72),ML
1 /LIMIT/LIMIT,ITEM,LL,IS,IX /DPY/ST(3900),RHY(100)
1 /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
1 /SCX/JALPHA(7),ISTAR,JAL(22),X,U,JZ,IRHY,JD,KA,KB,IZ
1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA
IF(MODE-4)33,44,555
33 CALL MX
RETURN
555 CALL SX
RETURN
44 IF(RMODE.GE.500)RETURN
C PICKS UP SLURS ONLY WHEN USING SUBR. 'EXTRA' *********
INVT=-1
LS=IS
C SAVE PTR TO RN ARRAY FOR SLUR FEATURE AT 614 (AND TREM. FEATURE)
JNTC=NTC
J=0
A=-1.
DO 1125 K=1,IZ
IF(R(1,K).GT.2)GO TO 1125
C GET BACK RHYTH. INFO IN P9 OF NOTES (FOR JDIF, COMPOSITE BEAMS)
B=R(3,K)
IF(A.EQ.B)GO TO 1125
C SKIP CHORD NOTES.
A=B
J=J+1
RHY(K)=V(J)
1125 CONTINUE
125 IF(REND.NE.0)GO TO 25
REND=3
25 DO 1500 K=1,72
IF(INP(K).EQ.LBB)GO TO 22
C B=AUTOMATIC BEAMS.
IF(INP(K).EQ.ISTAR)GO TO 15
1500 IF(INP(K).EQ.ISEMI)GO TO 500
15 INP(72)=ISTAR
GO TO 500
C ABOVE FOR 2ND LNE OF INPUT. IF LNS ENDS WITHOUT * OR ;, IT PUTS IN *
CC22 CALL BEAMQ
CC SUBROUTINE BEAMQ
CC COMMON /SCM/V(78),I,LCNT,STAFF,LIST(200),REND
CC 1 /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72),ML
CC 1 /SCX/JALPHA(7),ISTAR,JAL(22),X,U,JZ,IRHY,JD,KA,KB,IZ
CC 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG
CC 1 ,JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M
22 REREAD F78F,A,RB,RC
C TYPE '2B' OR '3B' ETC. FOR AUTOMATIC BEAMS. (2=DUPLE 3=TRIPLE)
IF(IREAD.NE.-1)GO TO 2222
A=RB
RB=RC
C IREAD=-1 WHEN READING SOS FILES. (=-2 WITH ET FILES.)
2222 A=A/2.
C '2'=1 '3'=1.5 '2B 3;' MEANS THERE'S A 3 NOTE PICK-UP.
CS IF(STEM)STEM=0
C STEM=10 OR 20 IF ALREADY SETUP IN NOTES
N=0
J=0
INP(72)=ISTAR
GR=4./88.
NN=0
NX=0
C NX IS REST COUNTER
NZ=0
NL=1
NJ=0
NR=1
JV=0
C JV IS VX COUNTER
C=0
B=A-.001
IF(RB.EQ.0)GO TO 122
J=RB
C RB=NUM OF PICKUP ITEMS.*******(NTS AND RSTS - BUT NOT GRACE NTS.)*******
B=-.001
DO 222 K=1,J
222 IF(V(K).NE.GR)B=B+ABS(V(K))
C ABOVE FOUND VALUE OF PICKUPS
122 X=ABS(V(NR))
IF(X.NE.GR)GO TO 2122
NN=NN+1
GO TO 2022
2122 C=C+X
C ADD ON RHYTH VALUE -- IF NOT GRACE NOTES
IF(V(NR))N=N+1
C FINDS RESTS AND GRACE NOTES (WE SKIP THEM)
IF(C.GT.B)GO TO 822
2022 IF(NR.EQ.IRHY)GO TO 422
922 NR=NR+1
C NR=RIGHT SIDE OF BEAM, NL=LEFT
GO TO 122
822 IF(NR-NL-NN-N.GT.0)GO TO 322
C IGNORE IF ONLY ONE NOTE FILLS UNIT
722 IF(NR.EQ.IRHY)GO TO 422
NN=0
NJ=NJ+N
NZ=NJ
N=0
NL=NR+1
C PUSH AHEAD FOR NEXT BEAM
622 B=B+A
C UPDATE SPACE POINTER
IF(C.GT.B)GO TO 622
GO TO 922
C MAIN AUTO BEAM SECTION.
322 DO 21 K=NL,NR-1
C THIS LOOP FINDS FIRST NOTE OF BEAM.
X=V(K)
IF(X)GO TO 21
IF(X.EQ.GR)GO TO 21
IF(NOTAIL(X))GO TO 21
C SKIP IF NOTE VAL. DOESN'T REQUIRE A TAIL
JV=JV+2
COUNTER FOR VX ARRAY (WHERE WE PUT BEAM'S NOTE NUMS.)
VX(JV-1)=K-NREST(K)
C FUNCT. NREST TELLS HOW MANY RESTS TO SUBTRACT
GO TO 221
21 CONTINUE
C IF WE GET HERE, NO BEAM NOTES FOUND.
GO TO 722
221 DO 321 K=NR,NL,-1
C THIS LOOP FINDS LAST NOTE OF BEAM.
X=V(K)
IF(X)GO TO 321
IF(X.EQ.GR)GO TO 321
IF(NOTAIL(X))GO TO 321
VX(JV)=K-NREST(K)
C NREST SUBTRACTS ALL INTERVENING RESTS
IF(VX(JV).EQ.VX(JV-1))JV=JV-2
CATCHES TRIPLET 1/8 TO TRIPLET 1/4, ETC.
GO TO 722
321 CONTINUE
C NEXT FOR BEAMED GRACE NOTES
422 N=0
J=1
1122 X=V(J)
IF(X)N=N+1
NR=0
IF(X.NE.GR)GO TO 1022
NL=J
DO 1222 K=J,IRHY
X=V(K)
IF(X.OR.X.NE.GR)GO TO 1322
C STOPS GRACE NOTE BEAM AT REST OR NON-GRACE
1222 NR=K
1322 IF(NR-NL.LE.0)GO TO 1022
CALL BAUTO(JV,NL,NR,N)
C UPDATE VX COUNTER
NL=NL+1
J=NR
1022 J=J+1
IF(J.LE.IRHY)GO TO 1122
1422 IF(JV.EQ.0)RETURN
C NO BEAMS - SO GO BACK.
DO 2822 K=JV+1,50
C USES ONLY 68 SLOTS IN 'V'
2822 VX(K)=0
CC END
J=0
GO TO 511
C ******* 1ST MAIN LOOP *********
500 REREAD F78F,VX
J=0
IF(IREAD.EQ.-1)J=1
C SKIPS LINE #S IN SOS FILES. (=-2 IS FOR ET FILES.)
511 J=J+1
N=VX(J)
JMP=1
JDIF=0
505 L=0
K=0
C=0
POS=-10.
RN(8+IS)=0
RN(9+IS)=0
IT=0
UPDN=0
CS IF(JSTEM.LT.*****0)GO TO 503
CS IF(STEM.EQ.0)GO TO 503
C UPDN=2=STEMS DOWN, (SLUR DIP UP) =1, OPPOSITE.
104 JA=J+1
B=VX(JA)
C THE 2ND NOTE (-=DIP DOWN ALWAYS; +100=UP ALWAYS, ORD.=AUTOMATIC)
IF(B.LT.100)GO TO 512
UPDN=2
B=B-100
IF(B.GT.100)B=100-B
C TYPE -NUM OR 200+NUM FOR DIP DOWN.
VX(JA)=B
512 IF(B)UPDN=1
RN(9+IS)=0
BRK=AMOD(VX(J),1.)*10.
IF(BRK.EQ.0)GO TO 503
C ADDS NUM TO BRACK. OR BEAM. ADD DESIRED .NUM TO 1ST NUM.(1.3=3)
RN(9+IS)=BRK+.0001
GO TO 5030
503 IF(N.GT.0)GO TO 5031
IT=-1
CALL SLEND
C -1= SLUR INTO 1ST NOTE.
C SETS POS OF LFT SIDE (-10+9, THEN +2)
GO TO 5060
5031 IF(N.LE.JNTC)GO TO 5030
C JNTC=NUM OF REAL NTS+1
CALL SLEND
C SLEND CHECKS ON END POINTS OF THIS STAFF
GO TO 504
C -1=1ST SLUR FROM NO NOTE; 99= LAST, TO NO NOTE
5032 IF(N.LE.JNTC)GO TO 5030
N=JNTC
C TRAPS ERROR OF TRYING TO PUT MARK ON NON-EXISTENT NOTE.
VX(J)=N
C VX(J)=N IS NEEDED AT LABEL 130
5030 L=L+1
502 K=K+1
IF(R(1,K).NE.1.)GO TO 502
C IS IT A NOTE?
P=R(3,K)
IF(P.EQ.POS)GO TO 502
C SKIPS DBLSTPS
POS=P
IF(L.LT.N)GO TO 506
IF(C.NE.0)GO TO 506
IF(R(10,K).EQ.0)C=19.-R(5,K)
C GET STEM DIR. OF 1ST NOTE ON MAIN STAFF
506 IF(L.LT.N)GO TO 5030
5060 IF(JMP)GO TO 504
C JMP=-1 MEANS END NOTE OF GROUP
J=J+1
NN=VX(J)
C IF 2ND NUM IS .LE. 1ST , THEN 2-NOTE SLUR. (-1 GOES TO 1)
IF(NN.EQ.0)NN=N+1
IF(NN.EQ.0)NN=1
IF(NN)GO TO 5061
IF(NN.LE.N)NN=N+1
C FOR USE WITH AUTO-BEAMS OR DIP UP. 2-NOTE SLUR OR BEAM UP.
CS777 IF(STEM.LE.0)GO TO 5061
CS GO TO 5061
C AUTOMATIC DIP DIRECTION FOR SLURS WITH AUTO. BEAMS.
CS177 MK=K
CS877 IF(R(1,MK).EQ.1)GO TO 477
CS MK=MK+1
CS GO TO 877
C FOR SLUR INTO FIRST NOTE WITH AUTO BEAMS.
CC477 IF(R(10,MK).EQ.0)GO TO 1077
C SKIP NOTES ON ANOTHER STAFF.
CC MK=MK+1
CC GO TO 477
CC477 CONTINUE
5061 MK=N
N=NN
CC N=IABS(NN)
M=K
JA=3
JB=4
KN=K
RB=0
GO TO 550
504 RB=2
IF(NN)RB=-RB
C DIP IS SET BY PARAM 7. (STEM DIR. IS AUTOMATIC)
550 RN(JA+IS)=POS
CX B=XNOTE(K)
B=ZNOTE(K)
C ZNOTE GETS HEIGHT AND CHECKS FOR NOTE ON OTHER STAFF/STEM DIR.
513 RN(JB+IS)=B+RB
C MK=# OF 1ST NOTE, N=END NOTE NOW
JMP=-JMP
IF(JMP.GT.0)GO TO 1503
C GO FIND RT. SIDE OF SLUR
JA=6
JB=5
IF(N.LE.MK)N=MK+1
C PICKS UP TYPO ERRORS
GO TO 503
1503 RN(2+IS)=STAFF
IF(NN.GE.0)GO TO 277
IF(C.GT.0)GO TO 377
277 IF(C.GE.0)GO TO 35
IF(NN.LE.0)GO TO 35
377 NN=-NN
35 RA=10.
C RA WILL=# OF TAILS, KN=1ST NOTE, K=LAST ('MOD' FOR DOTTED NOTES.)
RN(1+IS)=6
JMAX=0
IF(N-MK.EQ.1)JMAX=-1
DMAX=100.
UMAX=-DMAX
C FOR AUTO. BEAMS
JB=0
MB=0
C MB=-1 =GRACE NOTES UNDER BEAMS.
IF(ABS(R(4,KN)).GE.80.)MB=-1
RDIF=0
C JDIF AND RDIF ARE FOR NEW COMPOSITE BEAM FEATURE 5/78
JDIF=0
DO 2 L=KN,K
IF(R(1,L).NE.1)GO TO 2
IF(JDIF.NE.0)GO TO 1212
BB=RHY(L)
IF(BB.LE.0)GO TO 1212
IF(BB.EQ.4./88.)GO TO 1212
IF(RDIF.NE.0)GO TO 2212
RDIF=BB
C NOW WE HAVE FIRST RHYTH. VALUE UNDER BEAM
GO TO 1212
2212 IF(RDIF.EQ.BB)GO TO 1212
JDIF=L
KDIF=IS
C FOUND A DIFF. RHYTH. UNDER BEAM
CXCX1212 IF(R(10,L).NE.0)GO TO 2
C SKIP NOTES ON ANOTHER STAFF.**************?????????????
1212 BB=R(5,L)
IF(BB.GE.10.)GO TO 12
UPDN=-1
NN=19-AA
CHORDS WILL HAVE FIXED STEM DIRECTIONS ALWAYS
GO TO 2
C SKIPS NON-NOTES AND DBLSTPS
12 IF(MB)GO TO 10
AA=BB
RB=R(4,L)
IF(ABS(RB).GE.80)GO TO 2
C SKIPS GRACE NOTES
GO TO 110
10 RB=ZNOTE(L)
CX10 RB=XNOTE(L)
110 IF(RB.GT.UMAX)UMAX=RB
IF(RB.LT.DMAX)DMAX=RB
C FOR AUTO. BEAMS
RB=AMOD(R(7,L),10.0)
112 IF(RA.EQ.RB)GO TO 2
JB=-1
C FLAG FOR MIXED NUM. OF BEAMS
IF(RB.GE.RA)GO TO 2
IF(RB.NE.0)RA=RB
2 CONTINUE
C ABOVE FINDS SMALLEST # OF TAILS. NEXT FOR HGTS.
C ABOVE IS POS.2
IT=KN
M=3
203 IF(R(10,IT).EQ.0)GO TO 202
IF(JSTEM.GT.IT)GO TO 202
CS IF(STEM.LE.0)GO TO 202
C=RNW
IF(NN)GO TO 206
IF(R(5,IT).LT.20)GO TO 202
C=-C
GO TO 205
206 IF(R(5,IT).GE.20)GO TO 202
205 IF(ABS(R(4,IT)).GE.80.)C=C*.6
C FOR MINI BEAMS
RN(M+IS)=RN(M+IS)+C*RSTJ2
202 IF(IT.NE.KN)GO TO 201
IT=K
M=6
GO TO 203
C FOR EXTRA BEAMS WITH CHORDS. SAVE IT IN "IT"
201 IF(JSTEM.LE.IT)GO TO 577
CS201 IF(STEM.GT.0)GO TO 577
C *****↑↑↑↑↑↑ ABOVE WAS ".NE." BEFORE 4/30/76. WHY?#@&Xαε
IF(UPDN.NE.0)GO TO 577
NN=-1
IF(UMAX+DMAX.LT.14)NN=-NN
C SETS AUTO. BEAMS' STEM DIRECTION.
577 X=10
IF(NN)X=20
IF(MB)RA=2
C 2 BEAMS ON GRACE NOTES ALWAYS
X=X+RA
C # OF BEAMS. IT'S PUT IN DOWN BELOW 550.
200 M=KN
207 L=M+1
IF(R(1,L).NE.1)GO TO 307
IF(R(5,L).GE.10)GO TO 307
M=M+1
GO TO 207
C FOR HEIGHTS OF DBL STPS, ETC.
307 CONTINUE
CX607 A=XNOTE(M)
607 A=ZNOTE(M)
C A=NOTE 1.
UMAX=A
DMAX=A
C UP MAX. NOTE #, DOWN MAX. NOTE #.
407 M=K+1
IF(R(1,M).NE.1)GO TO 103
CC IF(R(9,M).NE.0)GO TO 103
IF(R(5,M).GE.10)GO TO 103
C FINDS DBL+ STP ON LAST OF BEAM
IF(R(6,M))GO TO 103
C JUMP OUT IF A WHITE NOTE
K=M
GO TO 407
103 IF(JSTEM.GT.KN)GO TO 604
CS103 IF(STEM.LE.0)GO TO 603
CZ NR=R(5,KN)/10.
CZ DO 703 M=KN+1,K
CZ IF(R(1,M).NE.1)GO TO 703
CZ NL=R(5,M)/10.
CZ IF(NL.EQ.0)GO TO 703
C JUMP IF CHORD NOTE (NO STEM)
CZ IF(NR.NE.NL)GO TO 603
CZ703 CONTINUE
C FLAG IS SET (NR) IF STEMS ARE SPECIFIED IN DIFF. DIRECTIONS. (GRACE NTS??)
604 NR=0
603 DO 3 M=KN,K
IF(R(1,M).NE.1)GO TO 3
CXCXCX IF(STEM.NE.0.AND.R(10,M).NE.0)GO TO 3
C SKIP NOTES ON OTHER STAFF
IF(M.EQ.K)GO TO 107
IF(R(1,M+1).NE.1)GO TO 107
C IT ONLY CARES ABOUT NOTES!
IF(R(5,M+1).LT.10)GO TO 3
C IGNORE LOWER (OR UPPER) NOTES OF CHORDS (NO STEM)-IN RE. UP-DOWN FEATURE.
107 IF(MB)GO TO 7
C SKIP IF DEALING WITH GRACE NOTE BEAMS. (MB=-1)
IF(ABS(R(4,M)).GE.100)GO TO 3
C SKIPS NON-NOTES
CX7 B=XNOTE(M)
7 B=ZNOTE(M)
CX677 IF(JSTEM.LE.M.AND.R(10,M).NE.0)GO TO 55
677 IF(JSTEM.LE.M)GO TO 55
C IGNORE STEM DIR. IF ALREADY SPECIFIED
STMDR=R(5,M)
IF(NN.GT.0)GO TO 5
C JUMP IF STEM UP
IF(STMDR.GE.20.)GO TO 55
IF(STMDR.LT.10.)GO TO 55
R(5,M)=STMDR+10.
GO TO 551
5 IF(STMDR.LT.20.)GO TO 55
R(5,M)=STMDR-10.
C************************
C STEM UP
551 INVT=0
55 IF(B.LT.UMAX)GO TO 13
CC55 IF(B.LE.UMAX)GO TO 13
C ↑↑↑↑↑↑↑↑ WAS .LT. !!!!! 5/76
UMAX=B
IF(JMAX)GO TO 3
IF(M.EQ.KN)GO TO 3
IF(M.EQ.K)GO TO 3
UMAX=UMAX+1
GO TO 3
13 IF(B.GT.DMAX)GO TO 3
DMAX=B
IF(JMAX)GO TO 3
IF(M.EQ.KN)GO TO 3
IF(M.NE.K)DMAX=DMAX-1
3 CONTINUE
C LOOKS FOR LOWER AND HIGHER NOTES THAN NOTE 1.
C*************************************
CZ GO TO 4
CZ IF(NR.EQ.0)GO TO 4
CZ C=14.
CZ IF(X.LT.20.)C=-C
C SHIFT FOR BEAMS FROM ONE STAFF TO ANOTHER WITH SPECIFIED STEM DIR.
CZ UMAX=UMAX+C
CZ P=C/7.
CZ DMAX=DMAX+P
CZ IF(A.LT.B)GO TO 400
CZ A=A+C
CZ B=B+P
CZ GO TO 4
CZ400 B=B+C
CZ A=A+P
4 K=IT
C FOR EXTRA BEAMS WITH CHORDS. K WAS SAVED IN "IT"
AA=A
BB=B
C=1
IF(X.LT.20.)GO TO 48
C JUMP IF STEM IS UP
CALL EXCH(AA,BB)
C=-C
CALL EXCH(UMAX,DMAX)
48 IF(AA.LT.BB)GO TO 45
IF(UMAX.EQ.A)GO TO 46
47 A=UMAX-C
B=A
GO TO 444
46 IF(UMAX.GT.AA)GO TO 47
GO TO 49
45 IF(UMAX.NE.B)GO TO 47
49 A=AA
B=BB
IF(X.GE.20)CALL EXCH(A,B)
444 RN(2+IS)=STAFF
446 DIS=(RN(IS+6)-RN(IS+3))/6.
C FOR TILT LATER --
IF(ABS(A-B).LT.DIS)GO TO 143
C=C*DIS
C NEW TILT ROUTINE. CONSIDERS DISTANCE:HEIGHT
C LIMITS SLOPE OF BEAM
IF(X.GE.20)GO TO 141
IF(B.GT.A)GO TO 140
142 B=A-C
GO TO 143
141 IF(B.GT.A)GO TO 142
140 A=B-C
CC143 BB=A
CC143 IF(STMDR.GE.20)GO TO 530
143 IF(X.GE.20)GO TO 530
CC IF(B.LT.A)BB=B
C BB IS LOWEST SIDE OF BEAM
CC IF(BB.GE.0)GO TO 14
C BEAM WILL ALWAYS TOUCH MIDDLE LINE OF STAFF
CC BB=-BB
IF(A.LT.0)A=0
IF(B.LT.0)B=0
GO TO 14
530 IF(A.GT.14)A=14
IF(B.GT.14)B=14
CC GO TO 430
CC530 IF(B.GT.A)BB=B
C FOR STEMS DOWN
CC IF(BB.LE.14)GO TO 14
C BEAMS WILL ALWAYS TOUCH MIDDLE LINE OF STAFF
CC BB=14-BB
CC430 A=A+BB
CC B=B+BB
C GETS NEW HEIGHT NUMBERS.
14 IF(MB.EQ.0)GO TO 330
C NEXT FOR GRACE NOTE BEAMS (MB=-1)
C=100
IF(A)C=-C
A=A+C
330 C=AMOD(X,10.0)-2
IF(C.LE.0)GO TO 331
C NEXT PUSHES OUT BEAMS IF 3 OR MORE.
C=C+1
IF(NN)C=-C
A=A+C
B=B+C
331 RN(4+IS)=A
RN(5+IS)=B
C MAKES HORIZONTAL BEAMS IF PATTERN IS UP-DOWN.
C*******?????? RN(6+IS)=R(3,K)
C ABOVE IS POS.2
C NEXT TO FIND TREMOLOS WHICH SHOULD BE PARALLEL TO BEAM.
JA=IX
AA=RN(IS+3)
BB=RN(IS+6)
300 IF(JA.GE.LS)GO TO 510
C LS IS PTR TO RN ARRAY BEFORE BEAMS WERE ADDED.
IF(RN(JA+1).EQ.6)GO TO 1300
2300 JA=RN(JA)+JA+3
C PUSH PTR AHEAD
GO TO 300
1300 C=RN(JA+3)
IF(C.LT.AA.OR.C.GT.BB)GOTO 2300
C NOW WE'VE FOUND TREM. WITHIN RANGE OF CURRENT BEAM.
RN(JA+9)=C
RN(JA+3)=AA
RN(JA+6)=BB
RN(JA+4)=A
RN(JA+5)=B
C=RN(JA+7)
IF(C.GT.-20.)GO TO 3300
IF(X.LT.20.)C=C+10
GO TO 4300
3300 IF(X.GE.20)C=C-10
4300 RN(JA+7)=C
C X=P7 INFO FOR CURRENT BEAM. (STEM DIR., NUM. OF BEAMS.)
RN(JA+10)=ABS(AMOD(X,10.0))
GO TO 2300
C ***********KN = 1ST NOTE, K=LAST NOTE.********
510 RN(7+IS)=X
RN(10+IS)=0
RN(IS+11)=-1
CALL UPDATE(9)
JA=IS
C************************************** BMX ***********
IF(JB)CALL BMX(RA)
IF(JA.NE.IS)GO TO 514
IF(JDIF.EQ.0)GO TO 514
C FOR NEW COMPOSITE BEAM FEATURE 4/78
IF(RA.EQ.1)GO TO 514
RN(7+KDIF)=X-1
RN(10+KDIF)=100
RN(8+KDIF)=R(3,JDIF-1)
RN(9+KDIF)=R(3,JDIF)
514 J=J+1
A=VX(J)
N=A
C SO ITEMS NEED NOT BE IN RIGHT ORDER.
IF(MOD(N,100).GT.IRHY)A=0
IF(A.NE.0)GO TO 505
IF(J.LT.50)GO TO 514
C SOMETIMES A SLASH IS SEEN AS A 0 (WHEN PRECEDED BY SPACE).
614 IF(INP(72).NE.ISTAR)GO TO 552
714 IF(INVT)RETURN
INVT=IS
CALL NEWR
IS=INVT
RETURN
552 CALL BMREAD
C TO READ MORE THAN 2 LINES.
GO TO 25
END
SUBROUTINE BMREAD
COMMON /FRMT/F78F(1),FA1(1),FA5(1),IREAD /ALF/INP(72),ML
1 /IDEV/IDEV
552 IF(IREAD.NE.0)GO TO 3501
CALL TYPE
IF(IDEV.EQ.5)WRITE(21,4501)INP
GO TO 1
3501 IF(IREAD.EQ.-1)READ(22,2501)J,INP
IF(IREAD.EQ.-2)READ(22,4501)INP
C FOR 2ND LINE.
CALL TYPOUT
1 CALL LNEND
4501 FORMAT(72A1)
2501 FORMAT(I,72A1)
END